home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / print / ppbas.sml < prev    next >
Encoding:
Text File  |  1993-02-11  |  30.4 KB  |  862 lines
  1. (* 1989, 1990, 1991 by AT&T Bell Laboratories *)
  2. (* ppbasics.sml *)
  3.  
  4. signature PPBASICS = 
  5. sig
  6.     val ppTuple: PrettyPrint.ppstream
  7.                  -> (PrettyPrint.ppstream -> 'a -> unit) -> 'a list -> unit
  8.     val ppFormals : PrettyPrint.ppstream -> int -> unit
  9.     val ppAccess: PrettyPrint.ppstream -> Access.access -> unit
  10.     val ppRep: PrettyPrint.ppstream -> Access.conrep -> unit
  11.     val ppDcon: PrettyPrint.ppstream -> Types.datacon -> unit
  12.     val ppVar: PrettyPrint.ppstream -> Variables.var -> unit
  13.     val ppSignature: PrettyPrint.ppstream 
  14.                      -> Modules.env * Modules.Signature * int -> unit
  15.     val ppSignatureVar: PrettyPrint.ppstream
  16.                         -> Modules.env * Modules.signatureVar * int -> unit 
  17.     val ppFunsigVar: PrettyPrint.ppstream
  18.                      -> Modules.env * Modules.funsigVar * int -> unit 
  19.     val ppStructure: PrettyPrint.ppstream
  20.                      -> Modules.env * Modules.Structure * int -> unit
  21.     val ppStructureVar: PrettyPrint.ppstream
  22.                         -> Modules.env * Modules.structureVar * int -> unit
  23.     val ppStructureName : PrettyPrint.ppstream
  24.                           -> Modules.env * Modules.Structure -> unit
  25.     val ppBinding: PrettyPrint.ppstream
  26.                    -> Modules.env * Modules.binding * int  -> unit
  27.     val ppFunctor : PrettyPrint.ppstream
  28.                     -> Modules.env * Modules.Functor * int -> unit
  29.     val ppFunctorVar : PrettyPrint.ppstream
  30.                        -> Modules.env * Modules.functorVar * int -> unit
  31.     val ppEnv : PrettyPrint.ppstream
  32.                 -> Modules.env * Modules.env * int * Symbol.symbol list option
  33.                 -> unit
  34.     val ppDebugDcon : PrettyPrint.ppstream
  35.                       -> Modules.env -> Types.datacon -> unit
  36.     val ppDebugVar: PrettyPrint.ppstream 
  37.                     -> Modules.env -> Variables.var -> unit
  38. end
  39.  
  40. structure PPBasics : PPBASICS = struct
  41.  
  42. structure PP = PrettyPrint;
  43. open PrettyPrint PPUtil Access Variables Types Fixity Modules
  44.  
  45. val internals = System.Control.internals
  46.  
  47. fun C f x y = f y x;
  48.  
  49. val pps = add_string
  50. fun ppi ppstrm (i:int) = pps ppstrm (makestring i)
  51. val ppType = PPType.ppType
  52. val ppTycon = PPType.ppTycon
  53. fun add_comma ppstrm = pps ppstrm ","
  54. fun add_comma_nl ppstrm  = (add_comma ppstrm; add_newline ppstrm)
  55. fun nl_indent ppstrm i = let val {linewidth,...} = dest_ppstream ppstrm 
  56.                          in
  57.                          add_break ppstrm (linewidth,i)
  58.                          end;
  59. fun nl_app ppstrm f =
  60.    let fun g [] = ()
  61.          | g [el] = f ppstrm el
  62.          | g (el::rst) = (f ppstrm el; add_newline ppstrm; g rst)
  63.    in  g
  64.    end;
  65.  
  66. fun br_app ppstrm f =
  67.    let fun g [] = ()
  68.          | g [el] = f ppstrm el
  69.          | g (el::rst) = (f ppstrm el; add_break ppstrm (1,0); g rst)
  70.    in  g
  71.    end;
  72.  
  73. fun en_pp ppstrm = {begin_block = PrettyPrint.begin_block ppstrm, 
  74.                     end_block = fn () => PrettyPrint.end_block ppstrm,
  75.                     pps = PrettyPrint.add_string ppstrm,
  76.                     add_break = PrettyPrint.add_break ppstrm,
  77.                     add_newline = fn () => PrettyPrint.add_newline ppstrm};
  78.  
  79. fun ppTyfun ppstrm env (TYFUN{arity,body}) =
  80.    let val {begin_block, end_block, pps, add_break,...} = en_pp ppstrm
  81.    in
  82.    (begin_block INCONSISTENT 2;
  83.     pps "TYFUN({arity="; 
  84.     ppi ppstrm arity; add_comma ppstrm;
  85.     add_break(0,0);
  86.     pps "body="; 
  87.     ppType env ppstrm body; 
  88.     pps "})";
  89.     end_block())
  90.    end;
  91.  
  92. fun ppArray ppstrm (f:ppstream -> 'a -> unit, a:'a array) =
  93.     let val {begin_block,pps,add_break,end_block,...} = en_pp ppstrm
  94.         fun loop i = 
  95.         let val elem = Array.sub(a,i)
  96.          in pps (makestring i);
  97.         pps ": "; 
  98.         f ppstrm elem;
  99.         add_break (1,0);
  100.         loop (i+1)
  101.         end
  102.      in begin_block INCONSISTENT 0;
  103.     loop 0 handle Array.Subscript => ();
  104.         end_block()
  105.     end
  106.  
  107. fun ppTuple ppstrm f =
  108.     ppClosedSequence ppstrm 
  109.       {front=C pps "(",
  110.        sep=fn ppstrm => (pps ppstrm ",";add_break ppstrm (0,0)),
  111.        back=C pps ")",
  112.        pr=f, style=INCONSISTENT}
  113.  
  114. fun ppFormals ppstrm =
  115.    let fun ppF 0 = ()
  116.          | ppF 1 = pps ppstrm " 'a"
  117.          | ppF n = (pps ppstrm " ";
  118.                     ppTuple ppstrm (fn ppstrm => fn s => pps ppstrm ("'"^s))
  119.                                    (PPType.typeFormals n))
  120.    in  ppF
  121.    end;
  122.  
  123. fun ppAccess ppstrm a = pps ppstrm (" ["^(Access.pr_access a)^"]");
  124.  
  125. fun ppRep ppstrm =
  126.    let val {pps,...} = en_pp ppstrm
  127.        val ppi = pps o (makestring:int->string)
  128.        val ppAccess = ppAccess ppstrm
  129.        fun ppR UNTAGGED = pps "UNTAGGED"
  130.          | ppR (TAGGED i) = (pps "TAGGED["; ppi i; pps "]")
  131.          | ppR (CONSTANT i) = (pps "CONSTANT["; ppi i; pps "]")
  132.          | ppR (TAGGEDREC(i,j)) =
  133.                (pps "TAGGEDREC["; ppi i; add_comma ppstrm; ppi j; pps "]")
  134.          | ppR (UNTAGGEDREC i) = (pps "UNTAGGEDREC["; ppi i; pps "]")
  135.          | ppR TRANSPARENT = pps "TRANSPARENT"
  136.          | ppR REF = pps "REF"
  137.          | ppR (VARIABLE a) = (pps "VARIABLE["; ppAccess a; pps "]")
  138.          | ppR (VARIABLEc a) = (pps "VARIABLEc["; ppAccess a; pps "]")
  139.    in  ppR
  140.    end;
  141.  
  142. fun ppDcon ppstrm =
  143.    let fun ppD(DATACON{name,rep=VARIABLE(access),...}) =
  144.               (ppSym ppstrm (name); 
  145.                if !internals then ppAccess ppstrm access else ())
  146.          | ppD(DATACON{name,rep=VARIABLEc(access),...}) =
  147.               (ppSym ppstrm (name); 
  148.                if !internals then ppAccess ppstrm access else ())
  149.          | ppD(DATACON{name,...}) = ppSym ppstrm (name)
  150.    in  ppD
  151.    end;
  152.  
  153. fun ppDebugDcon ppstrm env (DATACON{name,rep,const,typ,sign}) =
  154.    let val {begin_block,end_block,pps,add_break,...} = en_pp ppstrm
  155.        val ppSym = ppSym ppstrm
  156.    in
  157.    (begin_block CONSISTENT 3;
  158.     pps "DATACON";
  159.     add_break(0,0);
  160.     pps "{name = "; ppSym name; add_comma_nl ppstrm;
  161.     pps "const = "; pps (makestring const); add_comma_nl ppstrm;
  162.     pps "typ = "; ppType env ppstrm typ; add_comma_nl ppstrm;
  163.     pps "rep ="; ppRep ppstrm rep; add_comma_nl ppstrm;
  164. (*     pps "sign = ["; ppvseq ppstrm 0 "," (fn x=>ppRep x) sign; pps "]}"; *)
  165.      pps "sign = ["; ppvseq ppstrm 0 "," ppRep sign; pps "]}";
  166.     end_block())
  167.    end;
  168.  
  169. (* dconTyc: get the range type of a data constructor *)
  170.  
  171. fun dconTyc(DATACON{typ,const,...}) =
  172.     let fun f (POLYty{tyfun=TYFUN{body,...},...},b) = f (body,b)
  173.       | f (CONty(tyc,_),true) = tyc
  174.       | f (CONty(_,[_,CONty(tyc,_)]),false) = tyc
  175.       | f _ = ErrorMsg.impossible "ppdec.dconTyc"
  176.     in f (typ,const)
  177.     end
  178.  
  179. fun ppDatacon (env:Modules.env,DATACON{name,typ,...}) ppstrm =
  180.    let val {begin_block,end_block,pps,...} = en_pp ppstrm
  181.    in  (begin_block INCONSISTENT 0;
  182.         ppSym ppstrm name; pps " : "; ppType env ppstrm typ;
  183.         end_block())
  184.    end
  185.  
  186. fun ppConBinding ppstrm =
  187.  let val {begin_block,end_block,pps,...} = en_pp ppstrm
  188.      fun ppCon(DATACON{name,typ,rep=VARIABLE _,...},env) =
  189.              (begin_block CONSISTENT 0;
  190.               pps "exception "; ppSym ppstrm name; pps " of "; 
  191.               ppType env ppstrm (BasicTypes.domain typ);
  192.               end_block())
  193.        | ppCon (DATACON{name,typ,rep=VARIABLEc _,...},env) =
  194.               (begin_block CONSISTENT 0;
  195.                pps "exception "; ppSym ppstrm name;
  196.                end_block())
  197.        | ppCon (con,env) = 
  198.            let exception Hidden
  199.                val visibleDconTyc =
  200.                    case dconTyc con
  201.                      of RELtyc _ => true (* datacons always visible in sigs *)
  202.                       | tyc =>
  203.                             (TypesUtil.equalTycon
  204.                              (ModuleUtil.lookTYC (env,[TypesUtil.tycName tyc],
  205.                                                   fn _ => raise Hidden),
  206.                               tyc)
  207.                             handle Hidden => false)
  208.            in if !internals orelse not visibleDconTyc 
  209.            then (begin_block CONSISTENT 0;
  210.                  pps "con ";
  211.                  ppDatacon(env,con) ppstrm;
  212.                  end_block())
  213.        else ()
  214.            end
  215.  in  ppCon
  216.  end;
  217.  
  218. (* Support for a hack to make sure that non-visible ConBindings don't
  219.    cause spurious blank lines when pp-ing signatures.
  220. *)
  221. fun is_ppable_ConBinding (DATACON{name,typ,rep=VARIABLE _,...},_) = true
  222.   | is_ppable_ConBinding (DATACON{name,typ,rep=VARIABLEc _,...},_) = true
  223.   | is_ppable_ConBinding (con,env) = 
  224.       let exception Hidden
  225.       val visibleDconTyc =
  226.             case dconTyc con
  227.           of RELtyc _ => true (* datacons are always visible in sigs *)
  228.            | tyc => (TypesUtil.equalTycon
  229.                   (ModuleUtil.lookTYC (env,[TypesUtil.tycName tyc],
  230.                           fn _ => raise Hidden),
  231.                    tyc)
  232.                  handle Hidden => false)
  233.        in (!internals orelse not visibleDconTyc)
  234.       end
  235.  
  236. fun all_ppable_bindings alist env = 
  237.     fold (fn (c as CONbind con,L) => 
  238.                  if (is_ppable_ConBinding(con,env))
  239.                  then c::L
  240.                  else L
  241.        | (s as STRbind(STRvar{name,...}),L) =>
  242.         if (not (!internals)) andalso
  243.             (name=Extern.name_A) orelse (name=Extern.name_P)
  244.         then L else s::L
  245.            | (b,L) => b::L)
  246.          alist [];
  247.  
  248. fun ppVar ppstrm (VALvar {access,name,...}) =
  249.       (pps ppstrm (formatQid name);
  250.        if !internals then ppAccess ppstrm access else ())
  251.   | ppVar ppstrm (OVLDvar {name,...}) = (ppSym ppstrm (name); 
  252.                                          pps ppstrm " : overloaded")
  253.   | ppVar ppstrm (ERRORvar) = pps ppstrm "<ERRORvar>"
  254.  
  255. fun ppDebugVar ppstrm env  = 
  256.    let val {begin_block,end_block,pps,...} = en_pp ppstrm
  257.        val ppAccess = ppAccess ppstrm
  258.        fun ppDV(VALvar {access,name,typ}) = 
  259.             (begin_block CONSISTENT 0;
  260.              pps "VALvar";
  261.              begin_block CONSISTENT 3;
  262.              pps "({access="; ppAccess access; add_comma_nl ppstrm;
  263.              pps "name="; pps (formatQid name); add_comma_nl ppstrm;
  264.              pps "typ=ref "; ppType env ppstrm (!typ); 
  265.              pps "})";
  266.              end_block(); end_block())
  267.          | ppDV (OVLDvar {name,options,scheme}) = 
  268.              (begin_block CONSISTENT 0;
  269.               pps "OVLDvar";
  270.               begin_block CONSISTENT 3;
  271.               pps "({name="; ppSym ppstrm (name); add_comma_nl ppstrm;
  272.               pps "options=["; 
  273.               (ppvseq ppstrm 0 ","
  274.            (fn ppstrm => fn {indicator,variant} =>
  275.               (pps "{indicator=";ppType env ppstrm  indicator; 
  276.                    add_comma_nl ppstrm;
  277.                pps " variant ="; ppDebugVar ppstrm env variant; pps "}"))
  278.            (!options));
  279.               pps "]"; add_comma_nl ppstrm;
  280.               pps "scheme="; ppTyfun ppstrm env scheme; pps "})";
  281.              end_block(); end_block())
  282.          | ppDV (ERRORvar) = pps "<ERRORvar>"
  283.    in  ppDV
  284.    end;
  285.  
  286. fun ppStructureName ppstrm (env,str) =
  287.     let open ModuleUtil
  288.     val path =
  289.         case str
  290.           of SIMPLE{path,...} => path
  291.            | INSTANCE{path,...} => path
  292.            | _ => ErrorMsg.impossible "PPBasics.ppStructureName"
  293.     fun look(a,b) = case lookSTR(env,a,b)
  294.               of STRvar{binding,...} => binding
  295.      in pps ppstrm (findPath(path,str,eqOrigin,look))
  296.     end
  297.  
  298. fun ppVariable ppstrm  =
  299.    let val {begin_block,end_block,pps,...} = en_pp ppstrm
  300.        fun ppV(env:Modules.env,VALvar{name,access,typ}) = 
  301.               (begin_block CONSISTENT 0;
  302.                pps(formatQid name);
  303.                if !internals then ppAccess ppstrm access else ();
  304.                pps " : "; ppType env ppstrm (!typ);
  305.                end_block())
  306.          | ppV (env,OVLDvar {name,options=ref optl,scheme=TYFUN{body,...}}) =
  307.              (begin_block CONSISTENT 0;
  308.               ppSym ppstrm (name); pps " : "; ppType env ppstrm body; 
  309.               pps " as ";
  310.               ppSequence ppstrm
  311.                          {sep=C PrettyPrint.add_break(1,0),
  312.                   pr=(fn ppstrm => fn{variant,...} =>ppV(env,variant)),
  313.                   style=CONSISTENT}
  314.                     optl;
  315.               end_block())
  316.          | ppV(_,ERRORvar) = pps "<ERRORvar>"
  317.    in  ppV
  318.    end
  319.  
  320. and ppStructure ppstrm (topenv,str,depth) =
  321. let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm
  322.     fun ppSig bindings =
  323.       (begin_block CONSISTENT 0;
  324.        pps "sig";
  325.        add_break(1,2);
  326.        begin_block CONSISTENT 0;
  327.        ppEnv ppstrm (topenv,
  328.                  ModuleUtil.makeEnv(str,[]),
  329.                  depth-1,bindings);
  330.        end_block();
  331.        add_break(1,0);
  332.        pps "end";
  333.        end_block())
  334. in  case str
  335.       of SIMPLE {stamp,env=strenv,path} =>
  336.         if depth <= 1 
  337.         then pps "..."
  338.         else if !internals 
  339.          then (begin_block CONSISTENT 0;
  340.                pps "SIMPLE Stamp= ";
  341.                pps (Stamps.stampToString stamp);
  342.                add_newline();
  343.                pps "Path= ";
  344.                ppSymPath ppstrm path;
  345.                add_newline();
  346.                pps "Env=";
  347.                add_newline();
  348.                ppEnv ppstrm 
  349.                              (topenv,ModuleUtil.makeEnv(str,[]),depth-1,NONE);
  350.                end_block())
  351.          else ppSig NONE
  352.        | INSTANCE {origin,sign,subStrs,subFcts,types,path} =>
  353.        (if !internals 
  354.         then (begin_block CONSISTENT 2;
  355.           pps "INSTANCE";
  356.           add_newline();
  357.           begin_block CONSISTENT 0;
  358.           pps "Origin=";
  359.           ppStructure ppstrm (topenv,origin,depth-1);
  360.           case sign
  361.             of SIG{kind=ref EMBEDDED,...} => ()
  362.              | _ =>
  363.             (add_newline();
  364.              pps "Substructures:";
  365.              nl_indent ppstrm 2;
  366.              ppArray ppstrm 
  367.                                (fn ppstrm => fn a => 
  368.                                        ppStructure ppstrm 
  369.                                                    (topenv,a,depth-1),subStrs);
  370.              add_newline();
  371.              pps "Subfunctors:";
  372.              nl_indent ppstrm 2;
  373.              ppArray ppstrm 
  374.                                  (fn ppstrm => fn a =>
  375.                                           ppFunctor ppstrm
  376.                                                    (topenv,a,depth-1),subFcts);
  377.              add_newline();
  378.              pps "Types:";
  379.              nl_indent ppstrm 2;
  380.              ppArray ppstrm 
  381.                                  (fn ppstrm => fn t => 
  382.                                         ppTycon topenv ppstrm t,types));
  383.           add_newline();
  384.           pps "Path= ";
  385.           ppSymPath ppstrm path;
  386.           add_newline();
  387.           pps "Sign=";
  388.           ppSignature ppstrm (topenv,sign,depth-1);
  389.           end_block())
  390.         else case sign
  391.            of SIG{symbols,path,...} =>
  392.                let fun pp_str () =
  393.                    if depth <= 1 then pps "..."
  394.                    else ppSig (SOME(!symbols))
  395.                in case path
  396.                of SOME p =>
  397.                    ((if ModuleUtil.eqSign
  398.                     (sign,
  399.                      ModuleUtil.lookSIG
  400.                       (topenv,p, fn _ => raise Env.Unbound))
  401.                  then ppSym ppstrm p
  402.                  else pp_str())
  403.                 handle Env.Unbound => pp_str())
  404.                 | NONE => pp_str()
  405.                end
  406.             | FULL_SIG => pps "<full sig>"
  407.             | ERROR_SIG => pps "<error>")
  408.        | STR_FORMAL{pos,spec,...} =>
  409.        if depth <= 1 
  410.        then pps "..."
  411.        else if !internals then
  412.          (begin_block CONSISTENT 2;
  413.           pps "STR_FORMAL"; add_newline();
  414.           pps "pos="; ppi ppstrm pos; add_newline();
  415.           pps "spec=";
  416.           ppSignature ppstrm (topenv,spec,depth-1);
  417.           end_block())
  418.        else ppSignature ppstrm (topenv,spec,depth-1)
  419.        | SELF stamp => 
  420.        (pps "SELF "; 
  421.         pps (Stamps.stampToString stamp); 
  422.         add_newline())
  423.        | ERROR_STR => pps "<error>"
  424.        | APPLY{fct,arg,res} =>
  425.        if depth <= 1 then pps "...\n"
  426.        else if !internals then
  427.          (begin_block CONSISTENT 2;
  428.           pps "Structure resulting from an application";
  429.           add_newline();
  430.           pps "fct=";
  431.           ppFunctor ppstrm (topenv,fct,2);
  432.           add_newline();
  433.           pps "arg=";
  434.           ppStructure ppstrm (topenv,arg,2);
  435.           add_newline();
  436.           pps "res=";
  437.           ppStructure ppstrm (topenv,res,depth-1);
  438.           add_newline();
  439.           pps "end";
  440.           end_block())
  441.        else ppStructure ppstrm (topenv,res,depth-1)
  442.        | STR_OPEN{pos,spec,name} =>
  443.        if depth <= 1 then pps "...\n"
  444.        else if !internals then
  445.          (begin_block CONSISTENT 2;
  446.           pps "OPEN FORMAL";
  447.           add_newline();
  448.           pps "pos=";
  449.           ppIntPath ppstrm pos;
  450.           add_newline();
  451.           pps "name=";
  452.           ppSymPath ppstrm name;
  453.           add_newline();
  454.           pps "spec=";
  455.           ppSignature ppstrm (topenv,spec,depth-1);
  456.           end_block())
  457.        else ppSignature ppstrm (topenv,spec,depth-1)
  458.        | STR_ABSFB loc =>
  459.       (pps "STR_ABSFB(";
  460.        case loc
  461.          of PARAM path =>
  462.           (pps "PARAM "; ppIntPath ppstrm path)
  463.           | SEQind (index,path) =>
  464.           (pps "SEQ "; ppi ppstrm index; pps " "; ppIntPath ppstrm path)
  465.           | SEQ index =>
  466.           (pps "SEQ "; ppi ppstrm index);
  467.        pps ")";
  468.        add_newline())
  469. end        
  470.  
  471. and ppStructureVar ppstrm (env,STRvar{name,access,binding},depth) =
  472.    let val {begin_block,end_block,pps,add_break,...} = en_pp ppstrm
  473.    in
  474.    if (not (!internals)) andalso
  475.       ((name=Extern.name_A) orelse (name=Extern.name_P))
  476.    then ()
  477.    else (begin_block CONSISTENT 0;
  478.          pps "structure ";
  479.          ppSym ppstrm name;
  480.          if !internals then ppAccess ppstrm access else ();
  481.          pps " :";
  482.          add_break(1,2);
  483.          if name=Extern.name_P andalso false then pps "<parent def>"
  484.          else if name=Extern.name_A then pps "<argument def>"
  485.          else ppStructure ppstrm(env,binding,depth);
  486.          end_block())
  487.   end
  488.  
  489. and ppSignature ppstrm (env,sign,depth) =
  490.   let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm
  491.   in
  492.   if depth<=0 
  493.   then pps "..."
  494.   else
  495.   case sign
  496.     of SIG {symbols,env=ref sigenv,kind,path,stamp} =>
  497.           if !internals 
  498.           then 
  499.           (begin_block CONSISTENT 2;
  500.            pps "SIG";
  501.            add_newline();
  502.            pps "Path = ";
  503.            case path
  504.              of NONE => pps "NONE"
  505.               | SOME p => ppSym ppstrm p;
  506.            add_newline();
  507.            pps "Bound symbols = ";
  508.            ppSequence ppstrm {sep=C PrettyPrint.add_string ",", 
  509.                               pr=ppSym, style=INCONSISTENT}
  510.                      (!symbols);
  511.            add_newline();
  512.            pps "Kind =";
  513.            case !kind
  514.          of TOP {strcount,fctcount,typecount,slotcount,
  515.                      sConstraints,tConstraints} =>
  516.                  let fun ppConstraints (f,c) =
  517.                         ppArray ppstrm 
  518.                           (fn ppstrm => fn {internal,external} =>
  519.                              (begin_block INCONSISTENT 4;
  520.                               pps "Coherence:";
  521.                               add_newline(); (* 10 spaces in *)
  522.                               ppSequence ppstrm
  523.                                   {sep=fn ppstrm => (PP.add_string ppstrm " =";
  524.                                                      PP.add_break ppstrm (1,0)),
  525.                                       pr=ppSymPath,
  526.                       style=INCONSISTENT}
  527.                                          internal;
  528.                               end_block();
  529.                               add_newline();
  530.                               pps "Definitional:";
  531.                               case external
  532.                                 of NONE => ()
  533.                                  | SOME c => f c),
  534.                           Array.arrayoflist c)
  535.                      fun ppDefnStructure s = ppStructure ppstrm (env,s,depth-1)
  536.                  in nl_indent ppstrm 2; (* Now at 4 spaces in *)
  537.                 begin_block CONSISTENT 2;
  538.                     pps "TOP";
  539.                     add_newline();  (* Now at 6 spaces in *)
  540.                     pps "Strcount="; ppi ppstrm strcount;
  541.                     add_newline();
  542.                     pps "Fctcount="; ppi ppstrm fctcount;
  543.                     add_newline();
  544.                     pps "Typecount="; ppi ppstrm typecount;
  545.                     add_newline();
  546.                     pps "Slot count="; ppi ppstrm slotcount;
  547.                     add_newline();
  548.                     pps "Structure sharing constraints:";
  549.                     add_newline();
  550.                     ppConstraints (ppDefnStructure,sConstraints);
  551.                     add_newline();
  552.                     pps "Type sharing constraints:";
  553.                     add_newline();
  554.                     ppConstraints (ppTycon env ppstrm,tConstraints);
  555.                     end_block()
  556.                  end
  557.               | IRRELEVANT => pps "IRRELEVANT"
  558.               | EMBEDDED => pps "EMBEDDED";
  559.                             add_newline();
  560.                             pps "Stamp=";pps (Stamps.stampToString stamp);
  561.                             add_newline();
  562.                             pps "Env =";
  563.                             add_newline();
  564.                             ppEnv ppstrm (env,sigenv,depth-1,SOME(!symbols));
  565.                             end_block())
  566.           else (* not !internals *)
  567.           (begin_block CONSISTENT 0;
  568.        pps "sig";
  569.        add_break(1,2);
  570.        begin_block CONSISTENT 0;
  571.            ppEnv ppstrm (env,sigenv,depth-1,SOME(!symbols));
  572.            let fun ppConstraints (name,f,c) =
  573.                (* if internal=nil, then all the constraints were definitional.
  574.                   Thus there is no point in pping anything.*)
  575.               app (fn {internal=nil,...} => ()   
  576.             | {internal,external} =>
  577.             (add_newline();
  578.              begin_block INCONSISTENT 2;
  579.              pps "sharing ";
  580.              pps name;
  581.              ppSequence ppstrm {sep=fn ppstrm => 
  582.                                                    (PP.add_string ppstrm " =";
  583.                                                     PP.add_break ppstrm (1,0)),
  584.                         pr=ppSymPath,
  585.                         style=INCONSISTENT}
  586.                        internal;
  587.              case external
  588.                of NONE =>()
  589.                 | SOME c => (add_break(1,0); pps "= "; f c);
  590.                              add_break(1,0);  (* ? -kls *)
  591.                              end_block()))
  592.           c
  593.             in case !kind
  594.          of TOP {sConstraints,tConstraints,...} =>
  595.                      (ppConstraints("",fn s => ppStructureName ppstrm (env,s),
  596.                                     sConstraints);
  597.                       ppConstraints("type ",ppTycon env ppstrm,tConstraints))
  598.           | _ => ()
  599.            end;
  600.            end_block();
  601.        add_break(1,0);
  602.            pps "end";
  603.        end_block())
  604.      | FULL_SIG => pps "<full sig>"
  605.      | ERROR_SIG => pps "<error>"
  606.   end
  607.  
  608. and ppFunsig ppstrm (env,sign,depth) =
  609.   let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm
  610.   in
  611.   if depth<=0 then pps "..."
  612.   else case sign
  613.      of FSIG {paramName,argument,body,path} => 
  614.          if !internals
  615.          then (begin_block CONSISTENT 2;
  616.            pps " = ";
  617.            add_newline();
  618.            pps "fsig";
  619.            add_newline();
  620.            pps "param ="; ppSym ppstrm paramName;
  621.            add_newline();
  622.            pps "argument spec = ";
  623.            ppSignature ppstrm (env,argument,depth-1);
  624.            pps "body spec =";
  625.            ppSignature ppstrm (env,body,depth-1);
  626.            pps "end\n";
  627.            end_block())
  628.          else (pps "("; ppSym ppstrm paramName; pps ":<sig>) =";
  629.                    add_break(1,0);
  630.            ppSignature ppstrm (env,body,depth-1))
  631.      | FULL_FSIG => pps "<full fsig>"
  632.      | ERROR_FSIG => pps "<error fsig>"
  633.   end
  634.  
  635. (* assumes no newline is needed before pping *)
  636.  
  637. and ppSignatureVar ppstrm (env:Modules.env,SIGvar{name,binding},depth) =
  638.     let val {begin_block,end_block,pps,add_break,...} = en_pp ppstrm
  639.     in
  640.     (begin_block CONSISTENT 0;
  641.      pps "signature "; ppSym ppstrm name; pps " =";
  642.      add_break(1,2);
  643.      ppSignature ppstrm (env,binding,depth);
  644.      end_block())
  645.     end
  646.  
  647. and ppFunsigVar ppstrm (env:Modules.env,FSIGvar{name,binding},depth) =
  648.     let val {begin_block,end_block,pps,...} = en_pp ppstrm
  649.     in
  650.     (begin_block CONSISTENT 2;
  651.      pps "funsig "; ppSym ppstrm name; 
  652.      ppFunsig ppstrm (env,binding,depth);
  653.      end_block())
  654.     end
  655.  
  656. and ppFunctor ppstrm =
  657.  let val {begin_block,end_block,pps,add_break,add_newline} = en_pp ppstrm
  658.      fun ppF (env,FCT{paramName,argument,parent,
  659.                       body={tyseq,fctseq,strseq,str,fullstr},stamp},depth) =
  660.           if depth <= 1 
  661.           then pps "..."
  662.           else(begin_block CONSISTENT 0;
  663.                pps "paramName = "; pps (Symbol.name paramName);
  664.                add_newline();
  665.                pps "parent:";
  666.                nl_indent ppstrm 2;
  667.                ppStructure ppstrm (env,parent,1);
  668.                add_newline();
  669.                pps "argument signature:";
  670.                nl_indent ppstrm 2;
  671.                ppSignature ppstrm (env,argument,depth-1);
  672.                add_newline();
  673.                pps "type sequence:";
  674.                nl_indent ppstrm 2;
  675.                ppArray ppstrm (fn ppstrm => fn t => ppTycon env ppstrm t,
  676.                                Array.arrayoflist tyseq);
  677.                add_newline();
  678.                pps "structure sequence:";
  679.                nl_indent ppstrm 2;
  680.                ppArray ppstrm (fn ppstrm => fn s =>
  681.                                    ppStructure ppstrm (env,s,depth-1),
  682.                                                      Array.arrayoflist strseq);
  683.                add_newline();
  684.                pps "str:";
  685.                nl_indent ppstrm 2;
  686.                ppStructure ppstrm (env,str,depth-1))         
  687.        | ppF (topenv,FCT_FORMAL{pos,spec,...},depth) =
  688.           if depth <= 1 then pps "...\n"
  689.           else if !internals 
  690.                then(begin_block CONSISTENT 0;
  691.                 pps "FCT_FORMAL";
  692.                 add_newline();
  693.                 pps "pos="; ppi ppstrm pos;
  694.                 add_newline();
  695.                 pps "spec="; ppFunsig ppstrm (topenv,spec,depth-1);
  696.                 end_block())
  697.                else ppFunsig ppstrm (topenv,spec,depth-1)
  698.        | ppF (topenv,FCT_OPEN{pos,spec,name},depth) =
  699.           if depth <= 1 then pps "...\n"
  700.           else if !internals 
  701.                then (begin_block CONSISTENT 0;
  702.                  pps "FCT OPEN FORMAL";
  703.                  add_newline();
  704.                  pps "pos="; ppIntPath ppstrm pos;
  705.                  add_newline();
  706.                  pps "name="; ppSymPath ppstrm name;
  707.                  add_newline();
  708.                  pps "spec="; ppFunsig ppstrm (topenv,spec,depth-1);
  709.                  end_block())
  710.                else ppFunsig ppstrm (topenv,spec,depth-1)
  711.        | ppF (topenv,FCT_ABSFB loc,depth) =
  712.           (pps "FCT_ABSFB(";
  713.            case loc
  714.         of PARAM path => (pps "PARAM "; ppIntPath ppstrm path)
  715.          | SEQind (index,path) => (pps "SEQ "; ppi ppstrm index; pps " "; 
  716.                                        ppIntPath ppstrm path)
  717.          | SEQ index => (pps "SEQ "; ppi ppstrm index);
  718.            pps ")";
  719.            add_newline())
  720.        | ppF (topenv,FCT_INSTANCE{fsig,fct,parent},depth) =
  721.           if !internals 
  722.           then if depth <= 1 
  723.                then pps "...\n"
  724.            else (begin_block CONSISTENT 0;
  725.                  pps "FCT_INSTANCE";
  726.                  nl_indent ppstrm 2;
  727.                  pps "functor=";
  728.                  ppF (topenv,fct,depth-1);
  729.                  nl_indent ppstrm 2;
  730.                  pps "constraint=";
  731.                  ppFunsig ppstrm (topenv,fsig,depth-1);
  732.                  end_block())
  733.           else 
  734.       let val path = case fsig of FSIG{path,...} => path | _ => NONE
  735.          fun f() = if depth <= 1 then pps "...\n"
  736.                else ppFunsig ppstrm (topenv,fsig,depth-1)
  737.       in case path
  738.            of SOME p =>
  739.          ((if ModuleUtil.eqFsig
  740.                       (fsig,
  741.                ModuleUtil.lookFSIG(topenv,p,fn _ => raise Env.Unbound))
  742.            then (ppSym ppstrm p; add_newline())
  743.            else f()) handle Env.Unbound => f())
  744.             | NONE => f()
  745.       end
  746.        | ppF (_,ERROR_FCT,_) = pps "<error functor>"
  747.   in  ppF
  748.   end
  749.  
  750. (* assumes no newline is needed before pping "functor ..." *)
  751.  
  752. and ppFunctorVar ppstrm (env,FCTvar{name,access,binding},depth) =
  753.  let val {begin_block,end_block,pps,...} = en_pp ppstrm
  754.  in  (begin_block CONSISTENT 0;
  755.       pps "functor ";  pps(Symbol.name name);
  756.       if !internals then
  757.     (pps " = "; nl_indent ppstrm 2;
  758.      pps "access= "; ppAccess ppstrm access;
  759.      nl_indent ppstrm 2;
  760.      pps "binding="; nl_indent ppstrm 4;
  761.      ppFunctor ppstrm (env,binding,depth-1))
  762.       else pps " : <sig>";
  763.       end_block())
  764.  end
  765.  
  766. and ppTycBind ppstrm (env,tyc) =
  767.     let val {begin_block,end_block,pps,add_newline,...} = en_pp ppstrm
  768.         fun visibleDcons(tyc,dcons) =
  769.         let fun checkCON(CONbind c) = c
  770.           | checkCON _ = raise Env.Unbound
  771.         fun find ((actual as DATACON{name,...}) :: rest) =
  772.              (let val found = 
  773.                   checkCON(ModuleUtil.lookVARCON
  774.                     (env,[name],
  775.                      fn _ => raise Env.Unbound))
  776.                in if TypesUtil.eqTycon(dconTyc actual,dconTyc found)
  777.                   then actual :: find rest
  778.                   else find rest
  779.               end
  780.               handle Env.Unbound => find rest)
  781.           | find [] = []
  782.          in find dcons
  783.         end
  784.     val tyc' = case tyc
  785.              of FORMtyc{spec,...} => spec
  786.               | _ => tyc        
  787.     fun showit(arity, name) =
  788.         (if EqTypes.isEqTycon tyc'
  789.          then pps "eqtype" 
  790.          else pps "type";
  791.          ppFormals ppstrm arity; 
  792.          pps " ";
  793.          ppSym ppstrm name)
  794.      in begin_block CONSISTENT 2;
  795.     if !internals 
  796.     then (pps "type "; ppTycon env ppstrm tyc)
  797.         else (case tyc'
  798.         of GENtyc{path=name::_,arity,
  799.               kind=ref(DATAtyc dcons),...} =>
  800.             (case visibleDcons(tyc',dcons)
  801.                of [] => showit(arity,name)
  802.             | visdcons =>
  803.               (pps "datatype";
  804.                ppFormals ppstrm arity;
  805.                pps " ";
  806.                ppSym ppstrm name; 
  807.                add_newline();
  808.                nl_app ppstrm 
  809.                                   (fn ppstrm => fn DATACON{name,typ,...} => 
  810.                       (pps "con ";
  811.                        ppSym ppstrm name; 
  812.                        pps " : ";
  813.                        ppType env ppstrm typ))
  814.                    visdcons;
  815.                if length visdcons < length dcons
  816.                then (add_newline();
  817.                  pps "   ... hidden cons")
  818.                else ()))
  819.         | GENtyc{path=name::_,arity,...} => showit(arity,name)
  820.         | DEFtyc{path=name::_,tyfun=TYFUN{arity,...},...} =>
  821.             showit(arity,name)
  822.         | tycon =>
  823.            (pps "bogus tycon: ";
  824.             ppTycon env ppstrm tycon;
  825.             ErrorMsg.impossible "PPBas.ppBinder"));
  826.         end_block()
  827.     end
  828.  
  829. and ppBinding ppstrm (env:Modules.env,binding,depth) =
  830.     case binding
  831.       of VARbind var => (pps ppstrm "val "; ppVariable ppstrm (env,var))
  832.        | CONbind con => ppConBinding ppstrm (con,env)
  833.        | TYCbind tycon => ppTycBind ppstrm(env,tycon)
  834.        | SIGbind binding => ppSignatureVar ppstrm (env,binding,depth)
  835.        | FSIGbind binding => ppFunsigVar ppstrm (env,binding,depth)
  836.        | STRbind binding => ppStructureVar ppstrm (env,binding,depth)
  837.        | FCTbind binding => ppFunctorVar ppstrm (env,binding,depth)
  838.        | FIXbind(FIXvar{name,binding}) =>
  839.       (pps ppstrm (Fixity.fixityToString binding); ppSym ppstrm name)
  840.  
  841. (* ppEnv: pp an environment in the context of the top environment.
  842.    The environment must either be for a signature or be absolute (i.e.
  843.    all types and structures have been interpreted) *)
  844. (* Note: I make a preliminary pass over bindings to remove
  845.          invisible ConBindings -- Konrad.
  846.      and invisible structures too -- PC *)
  847. and ppEnv ppstrm (topenv,env,depth,boundsyms) =
  848.     let val bindings = 
  849.        case boundsyms
  850.          of NONE => map #2 (ModuleUtil.sortEnvBindings env)
  851.           | SOME l => map (fn x => Env.look(env,x)) l
  852.     val pp_env = Env.atop(env,topenv)
  853.      in ppSequence ppstrm
  854.                    {sep=add_newline,
  855.             pr=(fn ppstrm => fn binding => ppBinding ppstrm 
  856.                                                        (pp_env,binding,depth)),
  857.             style=CONSISTENT}
  858.     (all_ppable_bindings bindings pp_env)
  859.     end
  860.  
  861. end (* PPBasics *)
  862.